home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / SCPSDEMO.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  3.9 KB  |  154 lines
  1. ; SCPSDEMO.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;* This is an example of using SCOOPS. Please refer to chapter 5 in the    *
  12. ;* Language Reference Manual for TI Scheme.                *
  13. ;*                                    *
  14. ;*----------------------------------------------------------------------*
  15. ;*                                    *
  16. ;* Created by: TI            Date:                *
  17. ;* Revision history:                            *
  18. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  19. ;*                                    *
  20. ;*                    ``In nomine omnipotentii dei''    *
  21. ;************************************************************************
  22.  
  23. ;
  24. ; The first thing that needs to be done is to define classes for different
  25. ; types. We will define three types, points, lines and rectangles.
  26.  
  27. (load "scoops.fsl")
  28.  
  29. ;
  30. ; Point, Line and Rectangle
  31. ;
  32.  
  33. ;
  34. ; Class POINT
  35. ;
  36.  
  37. (define-class point
  38.           (instvars (x     (active 0       () move-x))
  39.             (y     (active 0       () move-y))
  40.             (color (active 'yellow () change-color)))
  41.           (options    settable-variables
  42.             inittable-variables))
  43.  
  44. (compile-class point)          ; see page 45 in the language reference manual
  45.  
  46. ;
  47. ; Class LINE
  48. ;
  49.  
  50. (define-class line
  51.           (instvars (len (active 50 () change-length))
  52.             (dir (active 0    () change-direction)))
  53.           (mixins point)  ; inherit x, y, and color from point class.
  54.           (options settable-variables))
  55.  
  56. (compile-class line)
  57.  
  58. ;
  59. ; Class RECTANGLE
  60. ;
  61.  
  62. (define-class rectangle
  63.           (instvars (height (active 60 () change-height)))
  64.           (mixins line)  ; inherit color and width (len) from line
  65.           (options settable-variables))
  66.  
  67. (compile-class rectangle)
  68.  
  69. ; In order to have an occurance of a class you will need to use the
  70. ; MAKE-INSTANCE procedure. For example:
  71. ;     (define p1 (make-instance point))
  72. ; Then to change parts of the class use the send function. For example
  73. ; to change the color of the point previously defined:
  74. ;     (send p1 change "color" 'cyan)
  75. ;
  76.  
  77. ;
  78. ; Methods for POINT
  79. ;
  80.  
  81. (define-method (point erase) ()
  82.            (set-pen-color! 'black)
  83.            (draw))
  84.  
  85. (define-method (point draw) ()
  86.            (draw-point x y))
  87.  
  88. ; having both a draw and redraw function here may seem to be unnecessary.
  89. ; you will see why both are needed as we continue
  90.  
  91. (define-method (point redraw) ()
  92.            (set-pen-color! color)
  93.            (draw))
  94.  
  95. (define-method (point move-x) (new-x)
  96.            (erase)
  97.            (set! x new-x)
  98.            (redraw)
  99.            new-x)
  100.  
  101. (define-method (point move-y) (new-y)
  102.            (erase)
  103.            (set! y new-y)
  104.            (redraw)
  105.            new-y)
  106.  
  107. (define-method (point change-color) (new-color)
  108.            (erase)
  109.            (set! color new-color)
  110.            (redraw)
  111.            new-color)
  112. ;
  113. ; Methods for LINE
  114. ;
  115.  
  116. ; inherit erase, redraw, move-x, move-y and change-color from point.
  117.  
  118. (define-method (line draw) ()
  119.            (position-pen x y)
  120.            (draw-line-to (truncate (+ x (* len (cos dir))))
  121.                  (truncate (+ y (* len (sin dir))))))
  122.  
  123. (define-method (line change-length) (new-length)
  124.            (erase)
  125.            (set! len new-length)
  126.            (redraw)
  127.            new-length)
  128.  
  129. (define-method (line change-direction) (new-dir)
  130.            (erase)
  131.            (set! dir new-dir)
  132.            (redraw)
  133.            new-dir)
  134.  
  135. ;
  136. ; Methods for RECTANGLE
  137. ;
  138.  
  139. ; inherit erase, redraw, move-x, move-y and change-color from point.
  140.  
  141. (define-method (rectangle draw) ()
  142.            (position-pen x y)
  143.            (draw-line-to (+ x len) y)
  144.            (draw-line-to (+ x len) (+ y height))
  145.            (draw-line-to x (+ y height))
  146.            (draw-line-to x y))
  147.  
  148. (define-method (rectangle change-height) (new-height)
  149.            (erase)
  150.            (set! height new-height)
  151.            (redraw)
  152.            new-height)
  153.  
  154.